home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / runtime / intext.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-07  |  21.1 KB  |  815 lines  |  [TEXT/MPS ]
  1. /* structured input/output */
  2.  
  3. #include "debugger.h"
  4. #include "fail.h"
  5. #include "gc.h"
  6. #include "intext.h"
  7. #include "io.h"
  8. #include "memory.h"
  9. #include "mlvalues.h"
  10. #include "reverse.h"
  11.  
  12. typedef unsigned long offset_t;
  13.  
  14. struct extern_obj {
  15.   value obj;
  16.   offset_t ofs;
  17. };
  18.  
  19. static offset_t * extern_block;
  20. static asize_t extern_size, extern_pos;
  21. static struct extern_obj * extern_table;
  22. static asize_t extern_table_size, extern_table_used;
  23.  
  24. #define Hash(v) (((asize_t) ((v) >> 2)) % extern_table_size)
  25.  
  26. #define Base_magic_number 0x8495A6B9
  27. #define Big_endian_32_magic_number Base_magic_number
  28. #define Little_endian_32_magic_number (Base_magic_number + 1)
  29. #define Big_endian_64_magic_number (Base_magic_number + 2)
  30. #define Little_endian_64_magic_number (Base_magic_number + 3)
  31. #define First_valid_magic_number Base_magic_number
  32. #define Last_valid_magic_number (Base_magic_number + 3)
  33.  
  34. #ifdef SIXTYFOUR
  35. # ifdef BIG_ENDIAN
  36. #  define Extern_magic_number Big_endian_64_magic_number
  37. # else
  38. #  define Extern_magic_number Little_endian_64_magic_number
  39. # endif
  40. #else
  41. # ifdef BIG_ENDIAN
  42. #  define Extern_magic_number Big_endian_32_magic_number
  43. # else
  44. #  define Extern_magic_number Little_endian_32_magic_number
  45. # endif
  46. #endif
  47.  
  48. static void alloc_table()
  49. {
  50.   asize_t i;
  51.  
  52.   extern_table = (struct extern_obj *)
  53.     stat_alloc(extern_table_size * sizeof(struct extern_obj));
  54.   for (i = 0; i < extern_table_size; i++)
  55.     extern_table[i].obj = 0;
  56. }
  57.  
  58. static void extern_too_big()
  59. {
  60.   stat_free((char *) extern_block);
  61.   stat_free((char *) extern_table);
  62.   failwith("extern: object too big");
  63. }
  64.  
  65. static void resize_result()
  66. {
  67.   extern_size = 2 * extern_size;
  68. #ifdef MAX_MALLOC_SIZE
  69.   if (extern_size > MAX_MALLOC_SIZE / sizeof(unsigned long))
  70.     extern_too_big();
  71. #endif
  72.   extern_block = (offset_t *)
  73.     stat_resize((char *) extern_block, extern_size * sizeof(offset_t));
  74. }
  75.  
  76. static void resize_table()
  77. {
  78.   asize_t oldsize;
  79.   struct extern_obj * oldtable;
  80.   asize_t i, h;
  81.  
  82.   oldsize = extern_table_size;
  83.   oldtable = extern_table;
  84.   extern_table_size = 2 * extern_table_size;
  85. #ifdef MAX_MALLOC_SIZE
  86.   if (extern_table_size > MAX_MALLOC_SIZE / sizeof(struct extern_obj))
  87.     extern_too_big();
  88. #endif
  89.   alloc_table();
  90.   for (i = 0; i < oldsize; i++) {
  91.     h = Hash(oldtable[i].obj);
  92.     while (extern_table[h].obj != 0) {
  93.       h++;
  94.       if (h >= extern_table_size) h = 0;
  95.     }
  96.     extern_table[h].obj = oldtable[i].obj;
  97.     extern_table[h].ofs = oldtable[i].ofs;
  98.   }
  99.   stat_free((char *) oldtable);
  100. }
  101.  
  102. static offset_t emit(v)
  103.      value v;
  104. {
  105.   mlsize_t size;
  106.   asize_t h;
  107.   offset_t res;
  108.   value * p;
  109.   offset_t * q;
  110.   asize_t end_pos;
  111.  
  112.   if (Is_long(v)) return (offset_t) v;
  113.   size = Wosize_val(v);
  114.   if (size == 0) return (Tag_val(v) << 2) + 2;
  115.   if (2 * extern_table_used >= extern_table_size) resize_table();
  116.   h = Hash(v);
  117.   while (extern_table[h].obj != 0) {
  118.     if (extern_table[h].obj == v) return extern_table[h].ofs;
  119.     h++;
  120.     if (h >= extern_table_size) h = 0;
  121.   }
  122.   end_pos = extern_pos + 1 + size;
  123.   while (end_pos >= extern_size) resize_result();
  124.   extern_block[extern_pos++] = Hd_val(v);
  125.   res = extern_pos * sizeof(offset_t);
  126.   extern_table[h].obj = v;
  127.   extern_table[h].ofs = res;
  128.   extern_table_used++;
  129.   for (p = &Field(v, 0), q = &extern_block[extern_pos]; size > 0; size--) {
  130.     *q++ = *p++;
  131.   }
  132.   extern_pos = end_pos;
  133.   return res;
  134. }
  135.  
  136. static offset_t emit_all(root)
  137.      value root;
  138. {
  139.   asize_t read_pos;
  140.   offset_t res;
  141.   header_t hd;
  142.   mlsize_t sz;
  143.   offset_t ofs;
  144.  
  145.   read_pos = extern_pos;
  146.   res = emit(root);
  147.   while (read_pos < extern_pos) {
  148.     hd = (header_t) extern_block[read_pos++];
  149.     sz = Wosize_hd(hd);
  150.     switch(Tag_hd(hd)) {
  151.     case String_tag:
  152.     case Double_tag:
  153.       read_pos += sz;
  154.       break;
  155.     case Abstract_tag:
  156.     case Final_tag:
  157.       invalid_argument("extern: abstract value");
  158.       break;
  159.     case Closure_tag:
  160.       invalid_argument("extern: functional value");
  161.       break;
  162.     default:
  163.       while (sz > 0) {
  164.         ofs = emit((value) extern_block[read_pos]);
  165.         extern_block[read_pos] = ofs;
  166.         read_pos++;
  167.         sz--;
  168.       }
  169.       break;
  170.     }
  171.   }
  172.   return res;
  173. }
  174.  
  175. #ifndef INITIAL_EXTERN_SIZE
  176. #define INITIAL_EXTERN_SIZE 4096
  177. #endif
  178. #ifndef INITIAL_EXTERN_TABLE_SIZE
  179. #define INITIAL_EXTERN_TABLE_SIZE 2039
  180. #endif
  181.  
  182. value extern_val(chan, v)       /* ML */
  183.      struct channel * chan;
  184.      value v;
  185. {
  186.   offset_t res;
  187.  
  188.   extern_size = INITIAL_EXTERN_SIZE;
  189.  
  190.   extern_block =
  191.     (offset_t *) stat_alloc(extern_size * sizeof(unsigned long));
  192.   extern_pos = 0;
  193.   extern_table_size = INITIAL_EXTERN_TABLE_SIZE;
  194.   alloc_table();
  195.   extern_table_used = 0;
  196.   res = emit_all(v);
  197.   if (extern_pos >= Max_wosize) extern_too_big();
  198.   stat_free((char *) extern_table);
  199.   putword(chan, Extern_magic_number);
  200.   putword(chan, extern_pos);
  201.   if (extern_pos == 0)
  202.     putword(chan, res);
  203.   else
  204.     putblock(chan, (char *) extern_block, extern_pos * sizeof(unsigned long));
  205.   stat_free((char *) extern_block);
  206.   return Atom(0);
  207. }
  208.  
  209. void adjust_pointers(start, size, color)
  210.      value *start;
  211.      mlsize_t size;
  212.      color_t color;
  213. {
  214.   value * p, * q;
  215.   mlsize_t sz;
  216.   header_t hd;
  217.   tag_t tag;
  218.   value v;
  219.   mlsize_t bosize;
  220.  
  221.   p = start;
  222.   q = p + size;
  223.   bosize = Bsize_wsize(size);
  224.   while (p < q) {
  225.     hd = *p;
  226.     sz = Wosize_hd(hd);
  227.     tag = Tag_hd(hd);
  228.     *p++ = Make_header(sz, tag, color);
  229.     if (tag >= No_scan_tag)
  230.       p += sz;
  231.     else
  232.       for( ; sz > 0; sz--, p++) {
  233.         v = *p;
  234.         switch(v & 3) {
  235.         case 0:                 /* 0 -> A bloc represented by its offset. */
  236.           Assert(v >= 0 && v <= bosize && (v & 3) == 0);
  237.           *p = (value) ((offset_t) start + v);
  238.           break;
  239.         case 2:                 /* 2 -> An atom. */
  240.           v = v >> 2;
  241.           Assert(v >= 0 && v < 256);
  242.           *p = Atom(v);
  243.           break;
  244.         default:                /* 1 or 3 -> An integer. */
  245.           break;
  246.         }
  247.       }
  248.   }
  249. }
  250.  
  251. /* Reverse all words in a block, in case of endianness clash.
  252.    Works with words of the natural word size. */
  253.  
  254. void rev_pointers(p, size)
  255.      value *p;
  256.      mlsize_t size;
  257. {
  258.   value * q;
  259.   header_t hd;
  260.   mlsize_t n;
  261.  
  262.   q = p + size;
  263.   while (p < q) {
  264.     Reverse_word(p);
  265.     hd = (header_t) *p++;
  266.     n = Wosize_hd(hd);
  267.     switch(Tag_hd(hd)) {
  268.     case Abstract_tag:
  269.     case Final_tag:
  270.       Assert (0);       /* Should not happen. Fall through for compatibility */
  271.     case String_tag:
  272.       p += n;
  273.       break;
  274.     case Double_tag:
  275.       Reverse_double(p);
  276.       p += n;
  277.       break;
  278.     default:
  279.       for( ; n > 0; n--, p++) {
  280.         Reverse_word(p);
  281.       }
  282.     }
  283.   }
  284. }
  285.  
  286. #ifdef SIXTYFOUR
  287.  
  288. /* Routines to convert 32-bit externed objects to 64-bit memory blocks. */
  289.  
  290. typedef int32 value32;
  291.  
  292. /* Reverse all words in a block, in case of endianness clash.
  293.    Works with 32-bit words. */
  294.  
  295. void rev_pointers_32(p, size)
  296.      value32 * p;
  297.      mlsize_t size;
  298. {
  299.   value32 * q;
  300.   header_t hd;
  301.   mlsize_t n;
  302.  
  303.   q = p + size;
  304.   while (p < q) {
  305.     Reverse_int32(p);
  306.     hd = (header_t) *p++;
  307.     n = Wosize_hd(hd);
  308.     switch(Tag_hd(hd)) {
  309.     case Abstract_tag:
  310.     case Final_tag:
  311.       Assert (0);       /* Should not happen. Fall through for compatibility */
  312.     case String_tag:
  313.       p += n;
  314.       break;
  315.     case Double_tag:
  316.       Reverse_double(p);
  317.       p += n;
  318.       break;
  319.     default:
  320.       for( ; n > 0; n--, p++) {
  321.         Reverse_int32(p);
  322.       }
  323.     }
  324.   }
  325. }
  326.  
  327. /* Compute the size of the expansion of a 32-bit externed block to a
  328.    64-bit block. The size is returned in 64-bit words. */
  329.  
  330. static mlsize_t size_after_expansion(p, len)
  331.      value32 * p;
  332.      mlsize_t len;              /* length in 32-bit words */
  333. {
  334.   mlsize_t res;
  335.   value32 * q;
  336.   header_t hd;
  337.   mlsize_t n;
  338.  
  339.   for (q = p + len, res = 0; p < q; /*nothing*/) {
  340.     hd = (header_t) *p++;
  341.     res++;
  342.     n = Wosize_hd(hd);
  343.     switch(Tag_hd(hd)) {
  344.     case String_tag:            /* round to the next 64-bit word */
  345.       res += (n * sizeof(value32) + sizeof(value) - 1) / sizeof(value);
  346.       break;
  347.     case Double_tag:
  348.       res += sizeof(double) / sizeof(value);
  349.       break;
  350.     case Abstract_tag:
  351.     case Final_tag:
  352.       Assert(0);                /* should not happen. */
  353.       break;
  354.     default:
  355.       res += n;                 /* all fields will be extended 32 -> 64 */
  356.       break;
  357.     }
  358.     p += n;
  359.   }
  360.   return res;
  361. }
  362.  
  363. /* Convert a 32-bit externed block to a 64-bit block. The resulting block
  364.    is a valid 64-bit object. */
  365.  
  366. static void expand_block(source, dest, source_len, dest_len, color)
  367.      value32 * source;
  368.      value * dest;
  369.      mlsize_t source_len, dest_len;
  370.      color_t color;
  371. {
  372.   value32 * p, * q;
  373.   value * d, * e;
  374.   header_t hd;
  375.   mlsize_t sz;
  376.   tag_t tag;
  377.   uint32 * forward_addr;
  378.   uint32 dest_ofs;
  379.   value v;
  380.  
  381.   /* First pass: copy the objects and set up forwarding pointers.
  382.      The pointers contained inside blocks are not resolved. */
  383.  
  384.   for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
  385.     hd = (header_t) *p++;
  386.     sz = Wosize_hd(hd);
  387.     tag = Tag_hd(hd);
  388.     forward_addr = (uint32 *) p;
  389.     dest_ofs = d + 1 - dest;
  390.     switch(tag) {
  391.     case String_tag:
  392.       { mlsize_t ofs_last_byte, len, new_sz;
  393.         ofs_last_byte = sz * sizeof(value32) - 1;
  394.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  395.         new_sz = (sz * sizeof(value32) + sizeof(value) - 1) / sizeof(value);
  396.         *d++ = Make_header(new_sz, String_tag, color);
  397.         Field(d, new_sz - 1) = 0;
  398.         bcopy(p, d, len);
  399.         ofs_last_byte = new_sz * sizeof(value) - 1;
  400.         Byte(d, ofs_last_byte) = ofs_last_byte - len;
  401.         p += sz;
  402.         d += new_sz;
  403.         break;
  404.       }
  405.     case Double_tag:
  406.       *d++ = Make_header(Double_wosize, Double_tag, color);
  407.       /* Cannot do *((double *) d) = *((double *) p) directly
  408.          because p might not be 64-aligned. */
  409.       Assert(sizeof(double) == sizeof(value));
  410.       ((value32 *) d)[0] = p[0];
  411.       ((value32 *) d)[1] = p[1];
  412.       p += sizeof(double) / sizeof(value32);
  413.       d += 1;
  414.       break;
  415.     case Abstract_tag:
  416.     case Final_tag:
  417.       Assert(0);
  418.     default:
  419.       *d++ = Make_header(sz, tag, color);
  420.       for (/*nothing*/; sz > 0; sz--, p++, d++) {
  421.         if ((*p & 1) == 0) {
  422.           *d = *((uint32 *) p);         /* copy, zero expansion */
  423.         } else {
  424.           *d = *((int32 *) p);          /* copy, sign expansion */
  425.         }
  426.       }
  427.       break;
  428.     }
  429.     *forward_addr = dest_ofs;   /* store the forwarding pointer */
  430.   }
  431.   Assert(d == dest + dest_len);
  432.  
  433.   /* Second pass: resolve pointers contained inside blocks,
  434.      replacing them by the corresponding forwarding pointer. */
  435.  
  436.   for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
  437.     hd = (header_t) *d++;
  438.     sz = Wosize_hd(hd);
  439.     tag = Tag_hd(hd);
  440.     if (tag >= No_scan_tag) {
  441.       d += sz;
  442.     } else {
  443.       for (/*nothing*/; sz > 0; sz--, d++) {
  444.         v = *d;
  445.         switch(v & 3) {
  446.         case 0:                 /* 0: a block represented by its offset */
  447.           Assert(v >= 0 && v < source_len * sizeof(value32) && (v & 3) == 0);
  448.           *d = (value) (dest + *((uint32 *)((char *) source + v)));
  449.           break;
  450.         case 2:                 /* 2: an atom */
  451.           v = v >> 2;
  452.           Assert(v >= 0 && v < 256);
  453.           *d = Atom(v);
  454.           break;
  455.         default:                /* 1 or 3: an integer */
  456.           break;
  457.         }
  458.       }
  459.     }
  460.   }
  461. }
  462.  
  463. #else /* !SIXTYFOUR */
  464.  
  465. #ifndef NO_SIXTYFOUR_INTERN
  466.  
  467. /* Routines to convert 64-bit externed objects to 32-bit memory blocks. */
  468.  
  469. typedef double value64;         /* Should work on just about any machine */
  470.  
  471. #ifdef BIG_ENDIAN
  472. #define MSword(p) (((value*) p)[0])
  473. #define LSword(p) (((value*) p)[1])
  474. #else
  475. #define MSword(p) (((value *) p)[1])
  476. #define LSword(p) (((value *) p)[0])
  477. #endif
  478.  
  479. /* Reverse all words in a block, in case of endianness clash.
  480.    Works with 64-bit words.
  481.    Returns (-1) if a header too large is encountered, 0 otherwise. */
  482.  
  483. int rev_pointers_64(p, size)
  484.      value64 * p;
  485.      mlsize_t size;             /* size in 64-bit words */
  486. {
  487.   value64 * q;
  488.   header_t hd;
  489.   mlsize_t n;
  490.  
  491.   q = p + size;
  492.   while (p < q) {
  493.     Reverse_int64(p);
  494.     hd = (header_t) LSword(p);
  495.     if (MSword(p) != 0) return -1;
  496.     p++;
  497.     n = Wosize_hd(hd);
  498.     switch(Tag_hd(hd)) {
  499.     case Abstract_tag:
  500.     case Final_tag:
  501.       Assert (0);       /* Should not happen. Fall through for compatibility */
  502.     case String_tag:
  503.       p += n;
  504.       break;
  505.     case Double_tag:
  506.       Reverse_double(p);
  507.       p += n;
  508.       break;
  509.     default:
  510.       for( ; n > 0; n --, p++) {
  511.         Reverse_int64(p);
  512.       }
  513.     }
  514.   }
  515.   return 0;
  516. }
  517.  
  518. /* Compute the size of the shrinkage of a 64-bit externed block to a
  519.    32-bit block. The size is returned in 32-bit words.
  520.    Return 0 if a block cannot be shrunk because its size is too big. */
  521.  
  522. static mlsize_t size_after_shrinkage(p, len)
  523.      value64 * p;
  524.      mlsize_t len;              /* length in 64-bit words */
  525. {
  526.   mlsize_t res;
  527.   value64 * q;
  528.   header_t hd;
  529.   mlsize_t n;
  530.  
  531.   for (q = p + len, res = 0; p < q; /*nothing*/) {
  532.     hd = (header_t) LSword(p);
  533.     if (MSword(p) != 0) return 0;
  534.     p++;
  535.     n = Wosize_hd(hd);
  536.     res++;
  537.     switch(Tag_hd(hd)) {
  538.     case String_tag:
  539.       { mlsize_t ofs_last_byte, len, new_sz;
  540.         ofs_last_byte = n * sizeof(value64) - 1;
  541.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  542.         new_sz = (len + sizeof(value)) / sizeof(value);
  543.         res += new_sz;
  544.         break;
  545.       }
  546.     case Double_tag:
  547.       res += sizeof(double) / sizeof(value);
  548.       break;
  549.     case Abstract_tag:
  550.     case Final_tag:
  551.       Assert(0);                /* should not happen. */
  552.       break;
  553.     default:
  554.       res += n;                 /* all fields will be shrunk 64 -> 32 */
  555.       break;
  556.     }
  557.     p += n;
  558.   }
  559.   return res;
  560. }
  561.  
  562. /* Convert a 64-bit externed block to a 32-bit block. The resulting block
  563.    is a valid 32-bit object.
  564.    Return -1 if the block cannot be shrunk because some integer literals
  565.    or relative displacements are too large, 0 otherwise. */
  566.  
  567. static int shrink_block(source, dest, source_len, dest_len, color)
  568.      value64 * source;
  569.      value * dest;
  570.      mlsize_t source_len, dest_len;
  571.      color_t color;
  572. {
  573.   value64 * p, * q;
  574.   value * d, * e;
  575.   header_t hd;
  576.   mlsize_t sz;
  577.   tag_t tag;
  578.   offset_t * forward_addr;
  579.   offset_t dest_ofs;
  580.   value v;
  581.  
  582.   /* First pass: copy the objects and set up forwarding pointers.
  583.      The pointers contained inside blocks are not resolved. */
  584.  
  585.   for (p = source, q = source + source_len, d = dest; p < q; /*nothing*/) {
  586.     hd = (header_t) LSword(p);
  587.     p++;
  588.     sz = Wosize_hd(hd);
  589.     tag = Tag_hd(hd);
  590.     forward_addr = (offset_t *) p;
  591.     dest_ofs = d + 1 - dest;
  592.     switch(tag) {
  593.     case String_tag:
  594.       { mlsize_t ofs_last_byte, len, new_sz;
  595.         ofs_last_byte = sz * sizeof(value64) - 1;
  596.         len = ofs_last_byte - Byte(p, ofs_last_byte);
  597.         new_sz = (len + sizeof(value)) / sizeof(value);
  598.         *d++ = Make_header(new_sz, String_tag, color);
  599.         Field(d, new_sz - 1) = 0;
  600.         bcopy(p, d, len);
  601.         ofs_last_byte = new_sz * sizeof(value) - 1;
  602.         Byte(d, ofs_last_byte) = ofs_last_byte - len;
  603.         p += sz;
  604.         d += new_sz;
  605.         break;
  606.       }
  607.     case Double_tag:
  608.       *d++ = Make_header(Double_wosize, Double_tag, color);
  609.       Store_double_val(d, Double_val(p));
  610.       p += sizeof(double) / sizeof(value64);
  611.       d += sizeof(double) / sizeof(value);
  612.       break;
  613.     case Abstract_tag:
  614.     case Final_tag:
  615.       Assert(0);
  616.     default:
  617.       *d++ = Make_header(sz, tag, color);
  618.       for (/*nothing*/; sz > 0; sz--, p++, d++) {
  619.         value lsw = LSword(p);
  620.         value msw = MSword(p);
  621.         if ((lsw & 1) == 0) {      /* If relative displacement: */
  622.           if (msw != 0) return -1; /* Check unsigned displacement fits in 32 */
  623.         } else {                   /* Otherwise, it's a signed integer */
  624.           if ((lsw >= 0 && msw != 0) || (lsw < 0 && msw != -1)) return -1;
  625.         }
  626.         *d = lsw;
  627.       }
  628.     }
  629.     *forward_addr = dest_ofs;   /* store the forwarding pointer */
  630.   }
  631.   Assert(d == dest + dest_len);
  632.  
  633.   /* Second pass: resolve pointers contained inside blocks,
  634.      replacing them by the corresponding forwarding pointer. */
  635.  
  636.   for (d = dest, e = dest + dest_len; d < e; /*nothing*/) {
  637.     hd = (header_t) *d++;
  638.     sz = Wosize_hd(hd);
  639.     tag = Tag_hd(hd);
  640.     if (tag >= No_scan_tag) {
  641.       d += sz;
  642.     } else {
  643.       for (/*nothing*/; sz > 0; sz--, d++) {
  644.         v = *d;
  645.         switch(v & 3) {
  646.         case 0:                 /* 0: a block represented by its offset */
  647.           Assert(v >= 0 && v < source_len * sizeof(value64) && (v & 7) == 0);
  648.           *d = (value) (dest + *((offset_t *)((char *) source + v)));
  649.           break;
  650.         case 2:                 /* 2: an atom */
  651.           v = v >> 2;
  652.           Assert(v >= 0 && v < 256);
  653.           *d = Atom(v);
  654.           break;
  655.         default:                /* 1 or 3: an integer */
  656.           break;
  657.         }
  658.       }
  659.     }
  660.   }
  661.   return 0;
  662. }
  663.  
  664. #endif /* NO_SIXTYFOUR_INTERN */
  665. #endif /* SIXTYFOUR */
  666.  
  667. static int really_getblock(chan, p, n)
  668.      struct channel * chan;
  669.      char * p;
  670.      unsigned long n;
  671. {
  672.   unsigned r;
  673.   while (n > 0) {
  674.     r = getblock(chan, p, (unsigned) n);
  675.     if (r == 0) return 0;
  676.     p += r;
  677.     n -= r;
  678.   }
  679.   return 1;
  680. }
  681.  
  682. value intern_val(chan)          /* ML */
  683.      struct channel * chan;
  684. {
  685.   value res;
  686.   unsigned long magic;
  687.   mlsize_t whsize, wosize;
  688.   unsigned long bhsize;
  689.   color_t color;
  690.   header_t hd;
  691.  
  692.   magic = getword(chan);
  693.   if (magic < First_valid_magic_number && magic > Last_valid_magic_number)
  694.     failwith("intern: bad object");
  695.   whsize = getword(chan);
  696.   if (whsize == 0) {
  697.     res = (value) getword(chan);
  698.     if (Is_long(res))
  699.       return res;
  700.     else
  701.       return Atom(res >> 2);
  702.   }
  703.   bhsize = Bsize_wsize (whsize);
  704.   wosize = Wosize_whsize (whsize);
  705. #ifdef SIXTYFOUR
  706.   if (magic == Little_endian_32_magic_number ||
  707.       magic == Big_endian_32_magic_number) {
  708.     /* Expansion 32 -> 64 required */
  709.     mlsize_t whsize32;
  710.     value32 * block;
  711.     whsize32 = whsize;
  712.     block = (value32 *) stat_alloc(whsize32 * sizeof(value32));
  713.     if (really_getblock(chan, block, whsize32 * sizeof(value32)) == 0) {
  714.       stat_free((char *) block);
  715.       failwith ("intern : truncated object");
  716.     }
  717. #ifdef BIG_ENDIAN
  718.     if (magic == Little_endian_32_magic_number)
  719.       rev_pointers_32(block, whsize32);
  720. #else
  721.     if (magic == Big_endian_32_magic_number)
  722.       rev_pointers_32(block, whsize32);
  723. #endif
  724.     whsize = size_after_expansion(block, whsize32);
  725.     wosize = Wosize_whsize(whsize);
  726.     res = alloc_shr(wosize, String_tag);
  727.     hd = Hd_val (res);
  728.     color = Color_hd (hd);
  729.     Assert (color == White || color == Black);
  730.     expand_block(block, Hp_val(res), whsize32, whsize, color);
  731.     stat_free((char *) block);
  732.   } else {
  733.     /* Block has natural word size (64) */
  734.     res = alloc_shr(wosize, String_tag);
  735.     hd = Hd_val (res);
  736.     color = Color_hd (hd);
  737.     Assert (color == White || color == Black);
  738.     if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
  739.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  740.       failwith ("intern : truncated object");
  741.     }
  742. #ifdef BIG_ENDIAN
  743.     if (magic == Little_endian_64_magic_number)
  744.       rev_pointers(Hp_val (res), whsize);
  745. #else
  746.     if (magic == Big_endian_64_magic_number)
  747.       rev_pointers(Hp_val (res), whsize);
  748. #endif
  749.     adjust_pointers(Hp_val (res), whsize, color);
  750.   }
  751. #else /* !SIXTYFOUR */
  752.   if (magic == Little_endian_64_magic_number ||
  753.       magic == Big_endian_64_magic_number) {
  754.     /* Shrinkage 64 -> 32 required */
  755. #ifdef NO_SIXTYFOUR_INTERN
  756.     failwith("intern: 64-bit object, cannot load");
  757. #else
  758.     mlsize_t whsize64;
  759.     value64 * block;
  760.     whsize64 = whsize;
  761.     block = (value64 *) stat_alloc(whsize64 * sizeof(value64));
  762.     if (really_getblock(chan, block, whsize64 * sizeof(value64)) == 0) {
  763.       stat_free((char *) block);
  764.       failwith ("intern : truncated object");
  765.     }
  766. #ifdef BIG_ENDIAN
  767.     if (magic == Little_endian_64_magic_number) {
  768. #else
  769.     if (magic == Big_endian_64_magic_number) {
  770. #endif
  771.       if (rev_pointers_64(block, whsize64) == -1) {
  772.         stat_free((char *) block);
  773.         failwith("intern: 64-bit object too big");
  774.       }
  775.     }
  776.     whsize = size_after_shrinkage(block, whsize64);
  777.     if (whsize == -1) {
  778.       stat_free((char *) block);
  779.       failwith("intern: 64-bit object too big");
  780.     }
  781.     wosize = Wosize_whsize(whsize);
  782.     res = alloc_shr(wosize, String_tag);
  783.     hd = Hd_val (res);
  784.     color = Color_hd (hd);
  785.     Assert (color == White || color == Black);
  786.     if (shrink_block(block, Hp_val(res), whsize64, whsize, color) == -1) {
  787.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  788.       stat_free((char *) block);
  789.       failwith("intern: 64-bit object too big");
  790.     }
  791.     stat_free((char *) block);
  792. #endif /* !NO_SIXTYFOUR_INTERN */
  793.   } else {
  794.     /* Block has natural word size (32) */
  795.     res = alloc_shr(wosize, String_tag);
  796.     hd = Hd_val (res);
  797.     color = Color_hd (hd);
  798.     Assert (color == White || color == Black);
  799.     if (really_getblock(chan, Hp_val(res), bhsize) == 0) {
  800.       Hd_val (res) = hd;                      /* Avoid confusing the GC. */
  801.       failwith ("intern : truncated object");
  802.     }
  803. #ifdef BIG_ENDIAN
  804.     if (magic == Little_endian_32_magic_number)
  805.       rev_pointers(Hp_val (res), whsize);
  806. #else
  807.     if (magic == Big_endian_32_magic_number)
  808.       rev_pointers(Hp_val (res), whsize);
  809. #endif
  810.     adjust_pointers(Hp_val (res), whsize, color);
  811.   }
  812. #endif /* !SIXTYFOUR */
  813.   return res;
  814. }
  815.